home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / derived / eq-ord.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.1 KB  |  70 lines  |  [TEXT/CCL2]
  1. ;;; ----------------------------------------------------------------
  2. ;;;  Eq
  3. ;;; ----------------------------------------------------------------
  4.  
  5. (define (Eq-fns algdata)
  6.   (list
  7.    (cond ((algdata-enum? algdata)
  8.       (**define '== '(|x| |y|)
  9.             (**== (**con-number (**var '|x|) algdata)
  10.               (**con-number (**var '|y|) algdata))))
  11.      (else
  12.       (**multi-define '== algdata
  13.               ;; For nullary constructors
  14.               (function **true)
  15.               ;; For unary constructors
  16.               (lambda (v1 v2)
  17.                 (**== (funcall v1) (funcall v2)))
  18.               ;; For n-ary constructors
  19.               (lambda (v1 v2 bool)
  20.                 (**and (**== (funcall v1) (funcall v2)) bool))
  21.               ;; The else clause in case the constructors do
  22.               ;; not match.
  23.               (if (algdata-tuple? algdata)
  24.                   '#f
  25.                   (function **false)))))))
  26.  
  27. ;;; ----------------------------------------------------------------
  28. ;;;  Ord
  29. ;;; ----------------------------------------------------------------
  30.  
  31. (define (Ord-fns algdata)
  32.   (list (ord-fn1 algdata '< (function **<))
  33.     (ord-fn1 algdata '<= (function **<=))))
  34.  
  35. (define (Ord-fn1 algdata fn prim)
  36.   (cond ((algdata-enum? algdata)
  37.      (**define fn '(|x| |y|)
  38.                (funcall prim (**con-number (**var '|x|) algdata)
  39.                      (**con-number (**var '|y|) algdata))))
  40.     ((algdata-tuple? algdata)
  41.      (**multi-define fn algdata
  42.                  (function **false)
  43.              (lambda (x y) (funcall prim (funcall x) (funcall y)))
  44.              (function combine-eq-<)
  45.              '#f))
  46.     (else
  47.      (**define fn '(|x| |y|)
  48.        (**let
  49.         (list 
  50.          (**multi-define '|inner| algdata
  51.                    (if (eq? fn '<) (function **false)
  52.                                (function **true))
  53.                    (lambda (x y)
  54.                  (funcall prim (funcall x) (funcall y)))
  55.                    (function combine-eq-<)
  56.                    '#f)
  57.          (**define '|cx| '() (**con-number (**var '|x|) algdata))
  58.          (**define '|cy| '() (**con-number (**var '|y|) algdata)))
  59.         (**or (**< (**var '|cx|) (**var '|cy|))
  60.           (**and (**== (**var `|cx|) (**var '|cy|))
  61.              (**app (**var '|inner|)
  62.                 (**var '|x|)
  63.                 (**var '|y|)))))))))
  64.  
  65. (define (combine-eq-< v1 v2 rest)
  66.   (**or (**< (funcall v1) (funcall v2))
  67.     (**and (**== (funcall v1) (funcall v2))
  68.            rest)))
  69.  
  70.